;;; -*-LISP-*-

(HERALD ARITH "")

(eval-when (compile) (load "scm:umacro"))

;;; SCHEME generic arithmetic procedures

(DEFUN-IMPORT (+ ADD) N
  (IF (= N 0)
      0
      (DO ((I 2 (1+ I))
	   (ANS (ARG 1) (PLUS ANS (ARG I))))
	  ((> I N) (COERCE-DOWNWARD ANS)))))

(DEFUN-IMPORT (- SUB) N
  (COND ((= N 0) 0)
	((= N 1) (MINUS (ARG 1)))
	(T (DO ((I 2 (1+ I))
		(ANS (ARG 1) (DIFFERENCE ANS (ARG I))))
	       ((> I N) (COERCE-DOWNWARD ANS))))))

(DEFUN-IMPORT (* MUL) N
  (IF (= N 0)
      1
      (DO ((I 2 (1+ I))
	   (ANS (ARG 1) (TIMES ANS (ARG I))))
	  ((> I N) (COERCE-DOWNWARD ANS)))))

(DEFUN-IMPORT (// DIV) N
  (COND ((= N 0) 1)
	((= N 1) (COERCE-DOWNWARD (QUOTIENT 1 (FLOAT (ARG 1)))))
	(T (DO ((I 2 (1+ I))
		(ANS (ARG 1) (QUOTIENT ANS (FLOAT (ARG I)))))
	       ((> I N) (COERCE-DOWNWARD ANS))))))


(DEFUN-IMPORT (-1+ DEC) (X) (COERCE-DOWNWARD (SUB1 X)))

(DEFUN-IMPORT (1+ INC) (X) (COERCE-DOWNWARD (ADD1 X)))


(ADD-TO-LISP-IMPORTS
 '(ABS (ZERO? ZEROP) (NEGATIVE? MINUSP) (POSITIVE? PLUSP) (INTEGER? FIXP)))


;;; integer arithmetic

(DEFUN-IMPORT (QUOTIENT SCH-QUOTIENT) (X Y)
  (QUOTIENT X Y))

(DEFUN-IMPORT MOD (X Y)
  (IF (AND (FIXP X) (FIXP Y))
      (REMAINDER X Y)
      (COERCE-DOWNWARD (DIFFERENCE X (TIMES (SCH-QUOTIENT X Y) Y)))))

(DEFUN-IMPORT INTEGER-DIVIDE (X Y)
  (CONS (QUOTIENT X Y) (MOD X Y)))

(ADD-TO-LISP-IMPORTS '((REMAINDER MOD) GCD))


;;; Floating to integer arithmetic

(DEFUN-IMPORT TRUNCATE (X)
  (IF (MINUSP X)
      (IF (FIXP X)
	  X
	  (1+ (FIX X)))
      (FIX X)))  

(DEFUN-IMPORT CEILING (X)
  (IF (FIXP X)
      X
      (1+ (FIX X))))

(DEFUN-IMPORT ROUND (X)
  (FIX (PLUS X .5)))

(ADD-TO-LISP-IMPORTS '((FLOOR FIX)))

(DEFUN-IMPORT (EXPT SCHEXPT) (X Y)
  (COERCE-DOWNWARD
   (IF (MINUSP Y)
       (EXPT (FLOAT X) Y)
       (EXPT X Y))))


(DEFUN-IMPORT (EXP SCHEXP) (X) (COERCE-DOWNWARD (EXP X)))
(DEFUN-IMPORT (LOG SCHLOG) (X) (COERCE-DOWNWARD (LOG X)))

(DEFUN-IMPORT (SIN SCHSIN) (X) (COERCE-DOWNWARD (SIN X)))
(DEFUN-IMPORT (COS SCHCOS) (X) (COERCE-DOWNWARD (COS X)))
(DEFUN-IMPORT (TAN SCHTAN) (X) (COERCE-DOWNWARD (QUOTIENT (SIN X) (COS X))))
(DEFUN-IMPORT (ATAN SCHATAN) (Y X) (COERCE-DOWNWARD (ATAN Y X)))
(DEFUN-IMPORT (SQRT SCHSQRT) (X) (COERCE-DOWNWARD (SQRT X)))
(DEFUN-IMPORT (ASIN SCHASIN) (Y R) (COERCE-DOWNWARD (ATAN Y (OTHER-SIDE Y R))))
(DEFUN-IMPORT (ACOS SCHACOS) (X R) (COERCE-DOWNWARD (ATAN (OTHER-SIDE X R) X)))

(DEFUN OTHER-SIDE (Y R) (SQRT (SUB (MUL R R) (MUL Y Y))))


(DEFUN-IMPORT (MAX SCHMAX) N
  (IF (= N 0)
      (SCH-ERROR "Too few arguments to MAX" N)
      (DO ((I 2 (1+ I))
	   (ANS (ARG 1) (IF (GREATERP (ARG I) ANS) (ARG I) ANS)))
	  ((> I N) (COERCE-DOWNWARD ANS)))))

(DEFUN-IMPORT (MIN SCHMIN) N
  (IF (= N 0)
      (SCH-ERROR "Too few arguments to MIN" N)
      (DO ((I 2 (1+ I))
	   (ANS (ARG 1) (IF (LESSP (ARG I) ANS) (ARG I) ANS)))
	  ((> I N) (COERCE-DOWNWARD ANS)))))

(DEFUN-IMPORT (= EQUALTO?) N
  (IF (< N 2)
      (SCH-ERROR "Too few arguments to =" `(= . ,(listify n))))
  (IF (NOT (NUMBERP (ARG 1)))
      (SCH-ERROR "Non-numeric argument to =" (ARG 1)))
  (DO ((I 2 (1+ I)) (CURRENT (ARG 1)))
      ((> I N) 'T)
    (IF (NOT (NUMBERP (ARG I)))
	(SCH-ERROR "Non-numeric argument to =" (ARG I)))
    (COND ((AND (BIGP CURRENT) (BIGP (ARG I)))		; Both bignums, so
	   (IF (NOT (EQUAL CURRENT (ARG I))) (RETURN NIL))) ; only EQUAL works.
	  ((FLOATP CURRENT)				; Must compare as
	   (IF (NOT (= CURRENT (FLOAT (ARG I))))	;  flonums.
	       (RETURN NIL)))
	  ((FLOATP (ARG I))				; Similarly, compare as
	   (IF (NOT (= (FLOAT CURRENT) (ARG I)))	;  flonums,
	       (RETURN NIL))
	   (SETQ CURRENT (ARG I)))			;  but must set current
	  ((OR (BIGP CURRENT) (BIGP (ARG I)))		; fixnum < bignum,
	   (RETURN NIL))				;  so fail.
	  ((= CURRENT (ARG I)))				; Else, we have fixnums
	  (T (RETURN NIL)))))

(DEFUN-IMPORT (<> NOT-EQUALTO?) N
  (NOT (APPLY #'EQUALTO? (LISTIFY N))))

(DEFUN-IMPORT (>= SCH->=) N
  (IF (< N 2)
      (SCH-ERROR "Too few arguments to >=" `(= ,@(listify n))))
  (IF (NOT (NUMBERP (ARG 1)))
      (SCH-ERROR "Non-numeric argument to >=" (ARG 1)))
  (DO ((I 2 (1+ I)) (CURRENT (ARG 1) (ARG I)))
      ((> I N) 'T)
    (IF (NOT (NUMBERP (ARG I)))
	(SCH-ERROR "Non-numeric argument to >=" (ARG I)))
    (COND ((LESSP CURRENT (ARG I)) (RETURN NIL)))))

(DEFUN-IMPORT (<= SCH-<=) N
  (IF (< N 2)
      (SCH-ERROR "Too few arguments to <=" `(= ,@(listify n))))
  (IF (NOT (NUMBERP (ARG 1)))
      (SCH-ERROR "Non-numeric argument to <=" (ARG 1)))
  (DO ((I 2 (1+ I)) (CURRENT (ARG 1) (ARG I)))
      ((> I N) 'T)
    (IF (NOT (NUMBERP (ARG I)))
	(SCH-ERROR "Non-numeric argument to <=" (ARG I)))
    (COND ((GREATERP CURRENT (ARG I)) (RETURN NIL)))))


(ADD-TO-LISP-IMPORTS  '((< LESSP) (> GREATERP)))


(DEFUN-IMPORT EVEN? (X)
  (NOT (ODDP X)))

(ADD-TO-LISP-IMPORTS '((ODD? ODDP)))

(DEFUN-IMPORT (HASH SCH-HASH) (OBJECT INTEGER)
  (AND (NOT (FIXP INTEGER))
       (SCH-ERROR "Second argument must be an integer -- HASH" INTEGER))
  (REMAINDER (ABS (SXHASH OBJECT)) INTEGER))

(DEFUN-IMPORT RANDOMIZE (N)
  (COND ((NULL N)
	 (SSTATUS RANDOM
		  (APPLY #'* (APPEND (STATUS DATE) (STATUS DAYTIME)))))
	((FIXP N)
	 (SSTATUS RANDOM N))
	(T
	 (SCH-ERROR "Arg must be an integer or NIL -- RANDOMIZE" N))))

(ADD-TO-LISP-IMPORTS '(RANDOM))

(DEFUN-IMPORT (RUNTIME SCH-RUNTIME) ()
  (- (RUNTIME) (STATUS GCTIME)))